{***************************************************************************}
{                                                                           }
{           Spring Framework for Delphi                                     }
{                                                                           }
{           Copyright (C) 2009-2011 DevJET                                  }
{                                                                           }
{           http://www.spring4d.org                                         }
{                                                                           }
{***************************************************************************}
{                                                                           }
{  Licensed under the Apache License, Version 2.0 (the "License");          }
{  you may not use this file except in compliance with the License.         }
{  You may obtain a copy of the License at                                  }
{                                                                           }
{      http://www.apache.org/licenses/LICENSE-2.0                           }
{                                                                           }
{  Unless required by applicable law or agreed to in writing, software      }
{  distributed under the License is distributed on an "AS IS" BASIS,        }
{  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. }
{  See the License for the specific language governing permissions and      }
{  limitations under the License.                                           }
{                                                                           }
{***************************************************************************}

unit Spring.Serialization;

{$I Spring.inc}

interface

uses
  Classes,
  Rtti,
  TypInfo,
  SysUtils,
  Spring,
  Spring.Collections,
  Spring.Reflection.ValueExpression,
  Spring.Serialization.Formatter;

type

  {$REGION 'Documentation'}
  ///	<summary>Fundamental interface which box an info of underlying serialized
  ///	type.</summary>
  ///	<seealso cref="IValueProvider"></seealso>
  {$ENDREGION}
  IReferenceProvider = interface(IValueProvider)
    ['{4D628A79-896D-4947-B74C-7710C4E09703}']
    {$REGION 'Property Accessors'}
      function GetReferenceType: TRttiType;
      function GetName: string;
      function GetAttributes: TArray<TCustomAttribute>;
      function GetIgnoreSerialization: Boolean;
      function GetVisibility: TMemberVisibility;
      function GetParent: IReferenceProvider;
      function GetIsWriteOnly: Boolean;
    {$ENDREGION}

    property Name: string read GetName;
    property ReferenceType: TRttiType read GetReferenceType;
    property Attributes: TArray<TCustomAttribute> read GetAttributes;
    property IgnoreSerialization: Boolean read GetIgnoreSerialization;
    property Visibility: TMemberVisibility read GetVisibility;
    property Parent: IReferenceProvider read GetParent;
    property IsWriteOnly: Boolean read GetIsWriteOnly;
  end;

  ///	<summary>Defines an interface of holder of method combined with
  ///	instance.</summary>
  IMethodReference = interface
    ['{BA344A59-EE16-4E58-AABF-B6B24958A996}']
    function Invoke(const Args: array of TValue): TValue;
  end;

  ///	<summary>It represent main serialization callback function which can pass
  ///	the control of serialization process further or just stops it.</summary>
  TSerializationCallback = reference to procedure(const instance: IReferenceProvider;
    const parentNode: IContentNode);

  TSerializerOperation = (soSerialization, soDeserialization);

  ITypeSerializer = interface
    ['{7011CCFE-6DCA-4357-9302-332240D05245}']
    {$REGION 'Property Accessors'}
      function GetSerializeCallback: TSerializationCallback;
      procedure SetSerializeCallback(const value: TSerializationCallback);
      function GetDeserializeCallback: TSerializationCallback;
      procedure SetDeserializeCallback(const value: TSerializationCallback);
    {$ENDREGION}

    function Accept(const instance: IReferenceProvider;
      operation: TSerializerOperation): Boolean;
    function Final(const instance: IReferenceProvider): Boolean;
    procedure Deserialize(const instance: IReferenceProvider; const parentNode: IContentNode);
    procedure Serialize(const instance: IReferenceProvider; const parentNode: IContentNode);
    property SerializeCallback: TSerializationCallback read GetSerializeCallback write SetSerializeCallback;
    property DeserializeCallback: TSerializationCallback read GetDeserializeCallback write SetDeserializeCallback;
  end;

  IgnoreSerialization = class(TCustomAttribute)
  end;

  TMemberVisibilitySet = set of TMemberVisibility;

  ISerializer = interface
    ['{76C9F7D0-CB4E-43FB-9D1C-3408B654E70C}']
    {$REGION 'Property Accessors'}
      function GetBackend: IFormatter;
      procedure SetBackend(const Value: IFormatter);
      function GetCustomSerializers: ICollection<ITypeSerializer>;
      function GetReferenceFilters: ICollection<TPredicate<IReferenceProvider>>;
      procedure SetVisibilityRanges(const Value: TMemberVisibilitySet);
      function GetVisibilityRanges: TMemberVisibilitySet;
    {$ENDREGION}

    procedure RegisterCustomSerializer(const value: ITypeSerializer);

    function Serialize(const instance: TValue): string; overload;
    procedure SerializeToFile(const instance: TValue; const fileName: string);
    procedure SerializeToStream(const instance: TValue; const stream: TStream);

    procedure Deserialize(const instance: TValue; const data: string); overload;
    procedure DeserializeFromStream(const instance: TValue; const data: TStream); overload;
    procedure DeserializeFromFile(const instance: TValue; const fileName: string); overload;

    function Deserialize(const data: string): TValue; overload;
    function DeserializeFromStream(const data: TStream): TValue; overload;
    function DeserializeFromFile(const fileName: string): TValue; overload;

    property Backend: IFormatter read GetBackend write SetBackend;
    property VisibilityRanges: TMemberVisibilitySet read GetVisibilityRanges write SetVisibilityRanges;
    property CustomSerializers: ICollection<ITypeSerializer> read GetCustomSerializers;
    property ReferenceFilters: ICollection<TPredicate<IReferenceProvider>> read GetReferenceFilters;
  end;

  TSerializer = class sealed(TInterfacedObject, ISerializer, IInterface)
  private
    fSerializers: ICollection<ITypeSerializer>;
    fCustomSerializers: ICollection<ITypeSerializer>;
    fReferenceFilters: ICollection<TPredicate<IReferenceProvider>>;
    fBackend: IFormatter;
    fVisibilityRanges: TMemberVisibilitySet;

    {$REGION 'Property Accessors'}
      function GetBackend: IFormatter;
      procedure SetBackend(const Value: IFormatter);
      procedure SetVisibilityRanges(const Value: TMemberVisibilitySet);
      function GetVisibilityRanges: TMemberVisibilitySet;
    {$ENDREGION}
    procedure DeserializeNode(const instance: IReferenceProvider; const parentNode: IContentNode);
    function DeserializeNodeWithSerializers(const instance: IReferenceProvider;
      const parentNode: IContentNode;
      const serializersList: ICollection<ITypeSerializer>): boolean;

    procedure SerializeNode(const instance: IReferenceProvider; const parentNode: IContentNode);
    function SerializeToTree(const instance: TValue): IContentDocument; overload;

    function GetSerializers: ICollection<ITypeSerializer>;
    function GetCustomSerializers: ICollection<ITypeSerializer>;
    function GetReferenceFilters: ICollection<TPredicate<IReferenceProvider>>;
    function SerializeNodeWithSerializers(const instance: IReferenceProvider;
      const parentNode: IContentNode;
      const serializersList: ICollection<ITypeSerializer>): boolean;

    property Serializers: ICollection<ITypeSerializer> read GetSerializers;
  public
    constructor Create;

    function Serialize(const instance: TValue): string; overload;
    procedure SerializeToFile(const instance: TValue; const fileName: string);
    procedure SerializeToStream(const instance: TValue; const stream: TStream);

    procedure Deserialize(const instance: TValue; const data: string); overload;
    procedure DeserializeFromStream(const instance: TValue; const data: TStream); overload;
    procedure DeserializeFromFile(const instance: TValue; const fileName: string); overload;

    function Deserialize(const data: string): TValue; overload;
    function DeserializeFromStream(const data: TStream): TValue; overload;
    function DeserializeFromFile(const fileName: string): TValue; overload;

    property Backend: IFormatter read GetBackend write SetBackend;

    procedure RegisterCustomSerializer(const value: ITypeSerializer); overload;

    property CustomSerializers: ICollection<ITypeSerializer> read GetCustomSerializers;
    property ReferenceFilters: ICollection<TPredicate<IReferenceProvider>> read GetReferenceFilters;

    property VisibilityRanges: TMemberVisibilitySet read GetVisibilityRanges write SetVisibilityRanges;
  end;

  TSerialization = class
  public
    class function CreateSerializer: ISerializer; static;
  end;

{$REGION 'Exceptions'}

  ESerializationException = class(Exception);

  ESerializationSourceCodeException = class(EIOException);
  ESourceFileException = class(EIOException);

{$ENDREGION}

const
  CItemsCollectionCodeName = 'Collection.Items';
  CItemsArrayCodeName = 'Array.Items';
  CItemCollectionCodeName = 'Item';
  CInstanceCollectionCodeName = 'Reference';
  CValueAttributeName = 'value';
  CTypeAttributeName = 'type';
  CNodeValueAttributeName = 'Node.Value';

implementation

uses
  Spring.Reflection,
  Spring.Serialization.ReferenceProvider,
  Spring.Serialization.ResourceStrings,
  Spring.Serialization.Formatter.XMLDocument,
  Spring.Serialization.TypeSerializers;


{$REGION 'TSerializer'}

constructor TSerializer.Create;
begin
  inherited Create;
  fVisibilityRanges := [mvPublic, mvPublished];
end;

function TSerializer.Deserialize(const data: string): TValue;
var
  stream: TStream;

//  document: IBackendDocument;
//  reference: IReferenceProvider;
//  reflector: IReflection;
//  instanceType: TRttiType;
begin
//  reflector := TReflection.Create;
//  instanceType := reflector.FindType(document.Root.Children.First.Attributes[CTypeAttributeName]);
//
//  if instanceType.TypeKind in [tkClass, tkInterface] then
//    Result := TActivator.CreateInstance(document.Root.Children.First.Attributes[CTypeAttributeName])
//  else
//    TValue.Make(nil, instanceType.Handle, Result);

  stream := TStringStream.Create(data);
  Result := DeserializeFromStream(stream);
  stream.Free;
end;

procedure TSerializer.DeserializeFromStream(const instance: TValue; const data: TStream);
var
  document: IContentDocument;
  reference: IReferenceProvider;
begin
  document := Backend.CreateDocument;
  document.LoadFromStream(data);

  if not instance.IsEmpty then
    reference := TValueReference.Create(instance, nil)
  else
    raise Exception.CreateResFmt(@SClassNotRegistered,
      [document.Root.Children.First.DeclaredType]);

  DeserializeNode(reference, document.Root);
end;

procedure TSerializer.DeserializeFromFile(const instance: TValue;
  const fileName: string);
var
  stream: TStream;
begin
  try
    stream := TFileStream.Create(fileName, fmOpenRead);
  except
    raise ESourceFileException.CreateRes(@SCodeNotFound);
  end;
  DeserializeFromStream(instance, stream);
  stream.Free;
end;

procedure TSerializer.Deserialize(const instance: TValue; const data: string);
var
  stream: TStream;
begin
  stream := TStringStream.Create(data);
  DeserializeFromStream(instance, stream);
  stream.Free;
end;

function TSerializer.DeserializeFromFile(const fileName: string): TValue;
var
  stream: TStream;
begin
  try
    stream := TFileStream.Create(fileName, fmOpenRead);
  except
    raise ESourceFileException.CreateRes(@SCodeNotFound);
  end;
  Result := DeserializeFromStream(stream);
  stream.Free;
end;

function TSerializer.DeserializeFromStream(const data: TStream): TValue;
var
  document: IContentDocument;
  reference: IReferenceProvider;
  reflector: IReflection;
  instanceType: TRttiType;
begin
  document := Backend.CreateDocument;
  document.LoadFromStream(data);

  reflector := TReflection.Create;
  instanceType := reflector.FindType(document.Root.Children.First.DeclaredType);

  if instanceType.TypeKind in [tkClass, tkInterface] then
    Result := TActivator.CreateInstance(document.Root.Children.First.DeclaredType)
  else
    TValue.Make(nil, instanceType.Handle, Result);

  if not Result.IsEmpty then
    reference := TValueReference.Create(Result, nil)
  else
    raise Exception.CreateResFmt(@SClassNotRegistered,
      [document.Root.Children.First.DeclaredType]);

  DeserializeNode(reference, document.Root);
end;

procedure TSerializer.DeserializeNode(const instance: IReferenceProvider;
  const parentNode: IContentNode);
var
  value: TValue;
begin
  value := instance.Value;
  if value.IsEmpty then
    Exit;

  if not DeserializeNodeWithSerializers(instance, parentNode, CustomSerializers) then
    DeserializeNodeWithSerializers(instance, parentNode, Serializers);
end;

function TSerializer.DeserializeNodeWithSerializers(const instance: IReferenceProvider;
  const parentNode: IContentNode; const serializersList: ICollection<ITypeSerializer>): boolean;
var
  serializer: ITypeSerializer;
  filter: TPredicate<IReferenceProvider>;
begin
  Result := False;

  if not instance.IgnoreSerialization and (instance.Visibility in VisibilityRanges) then
  begin
    for filter in ReferenceFilters do
    begin
      if not filter(instance) then
        Continue;
      for serializer in serializersList do
      begin
        if serializer.Accept(instance, soDeserialization) then
        begin
          serializer.Deserialize(instance, parentNode);
          if serializer.Final(instance) then
          begin
            Result := True;
            Break;
          end;
        end;
      end;
    end;
  end;
end;

function TSerializer.GetCustomSerializers: ICollection<ITypeSerializer>;
begin
  if not Assigned(fCustomSerializers) then
    fCustomSerializers := TCollections.CreateList<ITypeSerializer>;

  Result := fCustomSerializers;
end;

function TSerializer.GetReferenceFilters: ICollection<TPredicate<IReferenceProvider>>;
begin
  if not Assigned(fReferenceFilters) then
  begin
    fReferenceFilters := TCollections.CreateList<TPredicate<IReferenceProvider>>;

    fReferenceFilters.Add(
      function(const value: IReferenceProvider): Boolean
      begin
        Result := not ((value.Name = 'RefCount') and
          (value.Parent.ReferenceType.BaseType.Handle = TypeInfo(TInterfacedObject)));
      end
    );
  end;

  Result := fReferenceFilters;
end;

function TSerializer.GetBackend: IFormatter;
begin
  if not Assigned(fBackend) then
    fBackend := TXmlFormatter.Create;

  Result := fBackend;
end;

function TSerializer.GetSerializers: ICollection<ITypeSerializer>;
var
  serializer: ITypeSerializer;
begin
  if not Assigned(fSerializers) then
  begin
    fSerializers := TCollections.CreateList<ITypeSerializer>;
    fSerializers.Add(TScalarsSerializer.Create);
    fSerializers.Add(TEnumerableSerializer.Create);
    fSerializers.Add(TClassSerializer.Create);
    fSerializers.Add(TInterfaceSerializer.Create);
    fSerializers.Add(TRecordSerializer.Create);
    fSerializers.Add(TArraySerializer.Create);
    fSerializers.Add(TDynamicArraySerializer.Create);

    for serializer in fSerializers do
      serializer.SerializeCallback := SerializeNode;

    for serializer in fSerializers do
      serializer.DeserializeCallback := DeserializeNode;
  end;

  Result := fSerializers;
end;

function TSerializer.GetVisibilityRanges: TMemberVisibilitySet;
begin
  Result := fVisibilityRanges;
end;

procedure TSerializer.RegisterCustomSerializer(const value: ITypeSerializer);
begin
  CustomSerializers.Add(value);
end;

function TSerializer.Serialize(const instance: TValue): string;
var
  stream: TStringStream;
begin
  stream := TStringStream.Create;
  SerializeToStream(instance, stream);
  Result := stream.DataString;
  stream.Free;
end;

function TSerializer.SerializeToTree(const instance: TValue): IContentDocument;
var
  document: IContentDocument;
  reference: IReferenceProvider;
begin
  document := Backend.CreateDocument;
  document.Root.Name := 'Root';
  reference := TValueReference.Create(instance, nil);
  SerializeNode(reference, document.Root);
  Result := document;
end;

procedure TSerializer.SerializeNode(const instance: IReferenceProvider;
  const parentNode: IContentNode);
var
  value: TValue;
begin
  value := instance.Value;
  if value.IsEmpty then
    Exit;

  if not SerializeNodeWithSerializers(instance, parentNode, CustomSerializers) then
    SerializeNodeWithSerializers(instance, parentNode, Serializers);
end;

function TSerializer.SerializeNodeWithSerializers(const instance: IReferenceProvider;
  const parentNode: IContentNode; const serializersList: ICollection<ITypeSerializer>): boolean;
var
  serializer: ITypeSerializer;
  filter: TPredicate<IReferenceProvider>;
begin
  Result := False;

  if not instance.IgnoreSerialization and
    (instance.Visibility in VisibilityRanges) then
  begin
    for filter in ReferenceFilters do
    begin
      if not filter(instance) then
        Continue;
      for serializer in serializersList do
      begin
        if serializer.Accept(instance, soSerialization) then
        begin
          serializer.Serialize(instance, parentNode);
          if serializer.Final(instance) then
          begin
            Result := True;
            Break;
          end;
        end;
      end;
    end;
  end;
end;

procedure TSerializer.SerializeToFile(const instance: TValue;
  const fileName: string);
var
  stream: TFileStream;
begin
  try
    stream := TFileStream.Create(fileName, fmOpenWrite or fmCreate);
    stream.Size := 0;
  except
    raise ESourceFileException.CreateRes(@SCodeNotFound);
  end;

  SerializeToStream(instance, stream);
  stream.Free;
end;

procedure TSerializer.SerializeToStream(const instance: TValue;
  const stream: TStream);
begin
  SerializeToTree(instance).SaveToStream(stream);
end;

procedure TSerializer.SetBackend(const Value: IFormatter);
begin
  fBackend := Value;
end;

procedure TSerializer.SetVisibilityRanges(const Value: TMemberVisibilitySet);
begin
  fVisibilityRanges := Value;
end;

{$ENDREGION}


{ TSerialization }

class function TSerialization.CreateSerializer: ISerializer;
begin
  Result := TSerializer.Create;
end;


end.
